unit uSBDUnit_HiearchicalThreadClient;
// This unit serves the TThreadClientNode/ TThreadClientRootNode classes.
// These classes attempt to solve the generic problem of how to execute
//  a method on a hierarchy of generic nodes where:
//    (a) possibly some of these nodes are at risk of hanging the thread; and
//    (b) The calling client could equally well be either of these, without
//         altering the API.
//       (b.i)  The calling client is a main-threaded windowed client such
//              as a VCL Forms Application for Win32 or Win64 target.
//       (b.i) The calling client is a non-main thread which may be blocked
//              for a reasonable but finite time. Examples include an IIS web
//              server application or an Apache web server application.
// The model is that the execution method returns a boolean. The tree is
//  traversed, and if any node returns false, the whole traversal is aborted.
interface
uses Classes, Generics.Collections, windows, Messages, uSBDUnit_JobMill;

const
  WM_UnitTest = WM_USER + 21;

type

TThreadClientNodeStatus = (
  tcnodeNeutral,    // This node is in the queue to be processed.
  tcnodeDoing,      // We are currently procesing this node or one of its children.
  tcnodeDone,       // This node has been processed, either successfully or not.
  tcnodeSkipped     // This node will not be processed.
  );
TThreadClientNodeStatusSet = set of TThreadClientNodeStatus;

TMessageHandler = procedure (var Message: TMessage) of object;
IMainThreadedWindowedClient = interface
  ['{E2C98844-32CE-4CB2-97E2-E5D30955B4CF}']
  function  MainWindowHandle: HWND;
  procedure SetUnitTestHandler  ( UnitTest: TMessageHandler; Cookie: TObject); // Hook message WM_UnitTest
  procedure ClearUnitTestHandler( Cookie: TObject);
  procedure SetTimer( OnMaturation: TNotifyEvent; Period_ms: integer; Cookie: TObject);
  procedure ClearTimer( Cookie: TObject);
  end;


TNodalJob = class abstract( TJob)
  protected
    // Called in-thread
    procedure   Execute_InThread;        override;

    // Called out-of-thread
    procedure   Execute_OutOfThread;     override;
    class procedure TimedOut;            override;
  end;

TExecutionContext = class( TInterfacedPersistent)
  public
    FWindowedClient: IMainThreadedWindowedClient;
    FGenericJobMillService: IJobMillService;
    FMill: IJobMill;
    FCurrentJob: TNodalJob;
    FHangTimeOut_ms: integer;
    constructor Create( const WindowedClient: IMainThreadedWindowedClient);
    destructor Destroy; override;
  end;

TThreadClientNodeClass = class of TThreadClientNode;
TThreadClientNode = class( TEnumerable<TThreadClientNode>)
  private type
    TNodeVisitor = class( TInterfacedPersistent)
      protected
        FApplicableStatuses: TThreadClientNodeStatusSet;
        FRootNode: TThreadClientNode;
        function Visit( Node: TThreadClientNode): boolean; virtual;
      public
        function Parse( Node: TThreadClientNode): boolean;
      end;
    TNodeVisitorClass = class of TNodeVisitor;
    TExecutionVisitor = class( TNodeVisitor)
      protected
        function Visit( Node: TThreadClientNode): boolean; override;
      public
        FReturnNode: TThreadClientNode;
        FContext: TExecutionContext;
      end;
    TSetStatiiVisitor = class( TNodeVisitor)
      protected
        function Visit( Node: TThreadClientNode): boolean; override;
      public
        FNewStatus: TThreadClientNodeStatus;
      end;
    TVisitorInit = reference to procedure( Visitor: TNodeVisitor; Datum: TObject);

  private
    FOnStatusChange: TNotifyEvent;
    FThreadClientNodeStatus: TThreadClientNodeStatus;

    function DeepTraverse( VisitCls: TNodeVisitorClass;
                           Subset: TThreadClientNodeStatusSet;
                           Datum: TObject; InitProc: TVisitorInit): boolean;
    procedure ReleaseClientHooks( Context: TExecutionContext);
    procedure SetStatiiDeep(
     FromStatii: TThreadClientNodeStatusSet; ToStatus: TThreadClientNodeStatus);
    procedure SetStatus( Value: TThreadClientNodeStatus);

  protected
    FhasVisitedCore: boolean;

  public
    FdoInThread: boolean;
    FdoProcessCoreFirst: boolean;
    {$REGION 'FdoProcessCoreFirst Notes'}
    // FdoProcessCoreFirst = True  | The node core is processed before its
    //                             | children are parsed.
    // ----------------------------+--------------------------------------------
    // FdoProcessCoreFirst = False | The node core is processed after its
    //                             | children are parsed. This is the default.
    {$ENDREGION}

    procedure PreExecute;             virtual; abstract;
    function  Execute: boolean;       virtual; abstract;
    procedure PostExecute;            virtual; abstract; // Client thread only.

    function  ExecuteDeep( Context: TExecutionContext; ContinueFrom: TThreadClientNode): boolean;
    procedure ClearDeep;
    procedure SkipDeep;
    function  HangTimeOut_ms: integer;  virtual; // -1 for no time-out.
    procedure MarkAsHung;               virtual; abstract;

    constructor Create( doInThread1, doProcessCoreFirst1: boolean);

    property ThreadClientNodeStatus: TThreadClientNodeStatus read FThreadClientNodeStatus write SetStatus;
    property OnStatusChange: TNotifyEvent read FOnStatusChange write FOnStatusChange;
  end;


TThreadClientRootNode = class( TThreadClientNode)
  public
    FContext: TExecutionContext;
    procedure CommenceDeepExecution;
    constructor Create( OnStatusChange1: TNotifyEvent;
      const WindowedClient: IMainThreadedWindowedClient);
    destructor Destroy; override;
  end;

implementation














{ TThreadClientNode.TNodeVisitor }

function TThreadClientNode.TNodeVisitor.Parse( Node: TThreadClientNode): boolean;
var
  ChildNode: TThreadClientNode;
begin
result := True;

if not assigned( FRootNode) then
  FRootNode := Node;
Node.ThreadClientNodeStatus := tcnodeDoing;
try
  result := (not Node.FdoProcessCoreFirst) or
            (not (Node.ThreadClientNodeStatus in FApplicableStatuses)) or
            Visit( Node);
  if result then
    for ChildNode in Node do
      begin
      result := Parse( ChildNode);
      if not result then break
      end;
  result := result and
              (Node.FdoProcessCoreFirst or
              (not (Node.ThreadClientNodeStatus in FApplicableStatuses)) or
              Visit( Node))
finally
  if result then
    Node.ThreadClientNodeStatus := tcnodeDone;
  end
end;



function TThreadClientNode.TNodeVisitor.Visit( Node: TThreadClientNode): boolean;
begin
result := True
end;

{ TThreadClientNode.TExecutionVisitor }

function TThreadClientNode.TExecutionVisitor.Visit( Node: TThreadClientNode): boolean;
var
  WindowHandle: HWND;
  Job: TNodalExecuteJob;
  TimeOut: integer;
//  Mill: TJobMill;
begin
result := True;
if (Node.ThreadClientNodeStatus = tcnodeDone) and (Node <> FReturnNode) then
  exit;
if (Node.ThreadClientNodeStatus = tcnodeDone) and (Node = FReturnNode) then
  begin
  FReturnNode := nil;
  Exclude( FApplicableStatuses, tcnodeDone);
  exit
  end;
if Node.FhasVisitedCore then exit;
Node.FhasVisitedCore := True;
Node.PreExecute;
if Node.FdoInThread then
    begin
    Job := TNodalExecuteJob.Create;
    Job.FContext  := FContext;
    Job.FNode     := Node;
    Job.FRootNode := FRootNode;
    TimeOut := Node.HangTimeOut_ms;
    FContext.FHangTimeOut_ms := TimeOut;
//    if not assigned( FContext.FMill) then
//      FContext.FMill := TJobMill.Create;
    FContext.FCurrentJob  := Job;
    if assigned( FContext.FWindowedClient) then
        begin
        // Main-threaded Windowed client case.
        result := False;
        WindowHandle := FContext.FWindowedClient.MainWindowHandle;
        FContext.FWindowedClient.SetUnitTestHandler( Job.WndProc, Node);
        if TimeOut <> -1 then
          FContext.FWindowedClient.SetTimer( Job.TimeOutEvent, TimeOut, Node)
        end;
//    FContext.FMill.QueueJob( Job);
    if not assigned( FContext.FWindowedClient) then
        begin
        // Non Main-threaded blockable client case.
//        FContext.FMill.QueueJob( Job);
//        Job := FContext.FMill.WaitPop( TimeOut) as TNodalExecuteJob;
        FContext.FHangTimeOut_ms := -1;
        Node.ThreadClientNodeStatus := tcnodeDone;
        FContext.FCurrentJob := nil;
        if assigned( Job) then
            begin
            result := Job.FExecuteResult;
            Job.Free;
            Node.PostExecute
            end
          else
            begin
            result := False;
//            Mill := FContext.FMill;
            FContext.FMill := nil;
//            Mill.Abandon;
            Node.MarkAsHung
            end;
        if not result then
          FRootNode.SkipDeep
        end
    end
  else
    begin
    result := Node.Execute;
    Node.PostExecute;
    if not result then
      FRootNode.SkipDeep
    end;
end;

function TThreadClientNode.TSetStatiiVisitor.Visit( Node: TThreadClientNode): boolean;
begin
result := True;
Node.ThreadClientNodeStatus := FNewStatus;
if FNewStatus = tcnodeNeutral then
  Node.FhasVisitedCore := False
end;



{ TThreadClientNode }

constructor TThreadClientNode.Create( doInThread1, doProcessCoreFirst1: boolean);
begin
FdoInThread              := doInThread1;
FThreadClientNodeStatus  := tcnodeNeutral;
FdoProcessCoreFirst      := doProcessCoreFirst1
end;


function TThreadClientNode.DeepTraverse(
  VisitCls: TNodeVisitorClass;
  Subset: TThreadClientNodeStatusSet;
  Datum: TObject; InitProc: TVisitorInit): boolean;
var
  Visitor: TNodeVisitor;
begin
Visitor := VisitCls.Create;
try
  Visitor.FApplicableStatuses := Subset;
  if assigned( InitProc) then
    InitProc( Visitor, Datum);
  result := Visitor.Parse( self);
finally
  Visitor.Free
  end
end;


procedure TThreadClientNode.SetStatiiDeep(
  FromStatii: TThreadClientNodeStatusSet; ToStatus: TThreadClientNodeStatus);
begin
DeepTraverse( TSetStatiiVisitor, FromStatii, nil,
    procedure( Visitor: TNodeVisitor; Datum: TObject)
    begin
    TSetStatiiVisitor( Visitor).FNewStatus := ToStatus
    end)
end;


procedure TThreadClientNode.SetStatus( Value: TThreadClientNodeStatus);
begin
if FThreadClientNodeStatus = Value then exit;
FThreadClientNodeStatus := Value;
if assigned( FOnStatusChange) then
  FOnStatusChange( self)
end;



procedure TThreadClientNode.ClearDeep;
begin
SetStatiiDeep( [tcnodeDoing .. tcnodeSkipped], tcnodeNeutral)
end;

procedure TThreadClientNode.SkipDeep;
begin
SetStatiiDeep( [tcnodeNeutral], tcnodeSkipped);
SetStatiiDeep( [tcnodeDoing  ], tcnodeDone)
end;


function TThreadClientNode.ExecuteDeep(
  Context: TExecutionContext; ContinueFrom: TThreadClientNode): boolean;
type
  TParams = record
    FContext: TExecutionContext;
    FContinueFrom: TThreadClientNode;
    end;
  PParams = ^TParams;
var
  Params: TParams;
  NodesToDo: TThreadClientNodeStatusSet;
begin
Params.FContext      := Context;
Params.FContinueFrom := ContinueFrom;
NodesToDo := [tcnodeNeutral, tcnodeDoing, tcnodeSkipped];
if assigned( ContinueFrom) then
  Include( NodesToDo, tcnodeDone);
result := DeepTraverse( TExecutionVisitor, NodesToDo,
  TObject(@Params),
    procedure( Visitor: TNodeVisitor; Datum: TObject)
    begin
    TExecutionVisitor( Visitor).FContext    := PParams(Datum)^.FContext;
    TExecutionVisitor( Visitor).FReturnNode := PParams(Datum)^.FContinueFrom
    end)
end;

function TThreadClientNode.HangTimeOut_ms: integer;
begin
result := -1
end;


procedure TThreadClientNode.ReleaseClientHooks( Context: TExecutionContext);
begin
Context.FWindowedClient.ClearUnitTestHandler( self);
if Context.FHangTimeOut_ms <> -1 then
  Context.FWindowedClient.ClearTimer( self);
Context.FHangTimeOut_ms := -1;
ThreadClientNodeStatus := tcnodeDone
end;


{ TThreadClientRootNode }

procedure TThreadClientRootNode.CommenceDeepExecution;
begin
ClearDeep;
ExecuteDeep( FContext, nil)
end;



constructor TThreadClientRootNode.Create(
  OnStatusChange1: TNotifyEvent; const WindowedClient: IMainThreadedWindowedClient);
begin
inherited Create( False, False);
FContext := TExecutionContext.Create( WindowedClient)
end;

destructor TThreadClientRootNode.Destroy;
begin
FContext.Free;
inherited
end;

{ TNodalExecuteJob }

destructor TNodalExecuteJob.Destroy;
begin

  inherited;
end;

procedure TNodalExecuteJob.Execute;
begin
FExecuteResult := FNode.Execute
end;

procedure TNodalExecuteJob.Return;
begin
FNode.PostExecute;
if FExecuteResult then
    FRootNode.ExecuteDeep( FContext, FNode)
  else
    FRootNode.SkipDeep
end;

procedure TNodalExecuteJob.TimeOutEvent( Sender: TObject);
var
//  Job: TJob;
//  Mill: TJobMill;
  Node: TThreadClientNode;
begin
//Job := FContext.FCurrentJob;
//FContext.FCurrentJob := nil;
//Node := nil;
//if Job is TNodalExecuteJob then
//  begin
//  Node := TNodalExecuteJob( Job).FNode;
//  Node.ReleaseClientHooks( FContext);
//  Node.MarkAsHung;
//  end;
//if assigned( Job) then
//  begin
//  Job.Return;
//  Job.Free
//  end;
//Mill := FContext.FMill;
//FContext.FMill := nil;
//Mill.Abandon;
//if Node = FNode then
//  FRootNode.SkipDeep
end;


procedure TNodalExecuteJob.WndProc( var Message: TMessage);
//var
//  Job: TJob;
begin
//if Message.Msg <> WM_UnitTest then exit;
//if FContext.FCurrentJob <> self then
//  begin
//  // Job and its owning JobMill is abandoned.
//  Job := FContext.FMill.PeekPop;
//  if Job is TNodalExecuteJob then
//    TNodalExecuteJob( Job).FContext := nil;
//  if assigned( Job) then
//    Job.Free;
//  exit
//  end;
//if not assigned( FContext) then exit;
//Job := FContext.FMill.WaitPop( -1);
//if Job is TNodalExecuteJob then
//  TNodalExecuteJob( Job).FNode.ReleaseClientHooks( FContext);
//if assigned( Job) then
//  begin
//  FContext.FCurrentJob := nil;
//  Job.Return;
//  Job.Free
//  end;
//Message.Result := 1
end;

{ TExecutionContext }

constructor TExecutionContext.Create(
  const WindowedClient: IMainThreadedWindowedClient);
begin
FWindowedClient := WindowedClient;
FMill := nil;
FCurrentJob := nil;
FHangTimeOut_ms := -1
end;

destructor TExecutionContext.Destroy;
begin
FWindowedClient := nil;
//FMill.Free;
FCurrentJob := nil;
inherited;
end;

end.
